home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / defsystem.lisp < prev    next >
Text File  |  1990-09-18  |  11KB  |  334 lines
  1. ;;; -*- Mode:Lisp; Package:USER; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "USER")
  23.  
  24. #-kcl
  25. (progn
  26. #+explorer
  27. (defsystem clio
  28.   (:name "Common Lisp Interactive Objects")
  29.   (:short-name "CLIO")
  30.   (:pathname-default "clio:source;")
  31.   (:patchable "clio:patch;" "CLIO")
  32.   (:initial-status :experimental)
  33.  
  34.   ;;  The real source files...
  35.   (:module clio             ("clio"))
  36.   (:module defs             ("ol-defs" "utility"))
  37.   (:module core             ("core-mixins" "gravity"))
  38.   (:module images           "ol-images")
  39.   (:module buttons          "buttons")
  40.   (:module form             "form")
  41.   (:module table            "table")
  42.   (:module choices          "choices")
  43.   (:module scroller         "scroller")
  44.   (:module slider           "slider")
  45.   (:module scroll-frame     "scroll-frame")
  46.   (:module multiple-choices "mchoices")
  47.   (:module menu             "menu")
  48.   (:module property-sheet   "psheet")
  49.   (:module command          "command")
  50.   (:module confirm          "confirm")
  51.   (:module text-defs         ("buffer" "text-command")) 
  52.   (:module display-text     "display-text")
  53.   (:module edit-text        "edit-text")
  54.   (:module display-image    "display-imag")
  55.   (:module dialog-button    "dlog-button")
  56.  
  57.   ;;  The auxiliary files...
  58.   ;;(:module doc ("readme" "doc;clio.ps" "doc;release.1-0"))
  59.   ;;(:auxiliary doc)
  60.  
  61.   ;;  The transformations...
  62.   (:compile-load clio)
  63.   
  64.   (:compile-load defs
  65.          (:fasload clio)
  66.          (:fasload clio))
  67.   (:compile-load core
  68.          (:fasload clio defs)
  69.          (:fasload clio defs))
  70.   (:compile-load images
  71.          (:fasload clio defs)
  72.          (:fasload clio defs))
  73.   (:compile-load text-defs
  74.          (:fasload clio)
  75.          (:fasload clio))
  76.   (:compile-load display-text
  77.          (:fasload clio core text-defs)
  78.          (:fasload clio core text-defs))
  79.   (:compile-load confirm
  80.          (:fasload clio core display-text)
  81.          (:fasload clio core display-text))
  82.   (:compile-load edit-text
  83.          (:fasload clio core text-defs display-text confirm images)
  84.          (:fasload clio core text-defs display-text confirm images))
  85.   (:compile-load buttons
  86.          (:fasload clio core display-text images)
  87.          (:fasload clio core display-text images)) 
  88.   (:compile-load scroller
  89.          (:fasload clio core defs images)
  90.          (:fasload clio core defs images)) 
  91.   (:compile-load scroll-frame
  92.          (:fasload clio core scroller)
  93.          (:fasload clio core scroller))
  94.   (:compile-load slider
  95.          (:fasload clio core defs images)
  96.          (:fasload clio core defs images))
  97.   (:compile-load form
  98.          (:fasload clio core)
  99.          (:fasload clio core)) 
  100.   (:compile-load table
  101.          (:fasload clio core)
  102.          (:fasload clio core)) 
  103.   (:compile-load choices
  104.          (:fasload clio core table)
  105.          (:fasload clio core table)) 
  106.   (:compile-load multiple-choices
  107.          (:fasload clio core table)
  108.          (:fasload clio core table)) 
  109.   (:compile-load menu
  110.          (:fasload clio core display-text choices buttons defs images)
  111.          (:fasload clio core display-text choices buttons defs images)) 
  112.   (:compile-load property-sheet
  113.          (:fasload clio core form menu confirm display-text)
  114.          (:fasload clio core form menu confirm display-text))
  115.   (:compile-load command
  116.          (:fasload clio core form table confirm display-text)
  117.          (:fasload clio core form table confirm display-text))
  118.   (:compile-load dialog-button
  119.          (:fasload clio core confirm menu property-sheet command)
  120.          (:fasload clio core confirm menu property-sheet command))
  121.   (:compile-load display-image
  122.          (:fasload clio core)
  123.          (:fasload clio core))
  124.  
  125.   )
  126.  
  127.  
  128.  
  129. (defun load-clio (&key (host "CLIO") (directory "SOURCE") (compile-p t) (verbose-p t))
  130.   (dolist (file (mapcar
  131.           #'(lambda (name)
  132.               (make-pathname
  133.             :host      host
  134.             :directory directory
  135.             :name      name
  136.             :version   :newest))
  137.           '("CLIO"
  138.             "OL-DEFS"
  139.             "UTILITY"
  140.             "OL-IMAGES"
  141.             "CORE-MIXINS"
  142.             "GRAVITY"
  143.             "BUFFER"
  144.             "TEXT-COMMAND"
  145.             "DISPLAY-TEXT"
  146.             "BUTTONS"
  147.             "CONFIRM"
  148.             "SCROLLER"
  149.             "TABLE"
  150.             "CHOICES"
  151.             "FORM"
  152.             "MENU"
  153.             "PSHEET"
  154.             "COMMAND"
  155.             "EDIT-TEXT"
  156.             "SCROLL-FRAME"
  157.             "SLIDER"
  158.             "MCHOICES"
  159.             "DLOG-BUTTON"
  160.             "DISPLAY-IMAG"
  161.             )))
  162.     (when compile-p
  163.       (when verbose-p
  164.     (format t "~% Compiling ~12t~a..." file))
  165.       (compile-file file))
  166.     
  167.     (when verbose-p
  168.       (format t "~% Loading ~12t~a..." file))
  169.     (load file)
  170.     
  171.     (when (and compile-p verbose-p)
  172.       (format t "~%"))))
  173. )
  174.  
  175.  
  176. #+kcl
  177. (progn
  178.  
  179. (defvar *clio-root-directory* "/src/dec/dec-kcl/clue/clio")
  180.  
  181. (defvar *clio-source-pathname*
  182.     (pathname (format nil "~A/*.l" *clio-root-directory*)))
  183.  
  184. (defvar *clio-binary-pathname*
  185.     (pathname (format nil "~A/*.o" *clio-root-directory*)))
  186.  
  187. (defvar *clio-file-table* (make-hash-table :test 'equal))
  188.  
  189. (defun compile-clio (&optional
  190.              (source-pathname-defaults *clio-source-pathname*)
  191.              (binary-pathname-defaults *clio-binary-pathname*)
  192.              &key
  193.              (force-p nil))
  194.  
  195.   ;; The pathname-defaults above might only be strings, so coerce them
  196.   ;; to pathnames.  Build a default binary path with every component
  197.   ;; of the source except the file type.  This should prevent
  198.   ;; (compile-clio "*.lisp") from destroying source files.
  199.   (let* ((source-path (pathname source-pathname-defaults))
  200.      (path        (make-pathname
  201.                :host      (pathname-host      source-path)
  202.                :device    (pathname-device    source-path)
  203.                :directory (pathname-directory source-path)
  204.                :name      (pathname-name      source-path)
  205.                :type      nil
  206.                :version   (pathname-version   source-path)))
  207.      (binary-path (merge-pathnames binary-pathname-defaults
  208.                        path)))
  209.                        
  210.     ;; Make sure source-path and binary-path file types are distinct so
  211.     ;; we don't accidently overwrite the source files.  NIL should be an
  212.     ;; ok type, but anything else spells trouble.
  213.     (if (and (equal (pathname-type source-path)
  214.             (pathname-type binary-path))
  215.          (not (null (pathname-type binary-path))))
  216.     (error "Source and binary pathname defaults have same type ~s ~s"
  217.            source-path binary-path))
  218.  
  219.     (format t ";;; Default paths: ~s ~s~%" source-path binary-path)
  220.  
  221.     (let ((newest-source-fwd 0))
  222.       (labels ((compile-lisp (filename &optional (binary-filename filename))
  223.          (let ((source (merge-pathnames filename source-path))
  224.                (binary (merge-pathnames binary-filename binary-path)))
  225.            (when (or force-p
  226.                  (not (probe-file source)) ; maybe no type in pathname
  227.                  (not (probe-file binary))
  228.                  (< (file-write-date binary)
  229.                 (setq newest-source-fwd
  230.                       (max newest-source-fwd
  231.                        (file-write-date source)))))
  232.              ;; If the source and binary pathnames are the same,
  233.              ;; then don't supply an output file just to be sure
  234.              ;; compile-file defaults correctly.
  235.              #+(or kcl ibcl) (load source)
  236.              (if (equal source binary)
  237.              (compile-file source)
  238.              (compile-file source :output-file binary)))
  239.            binary))
  240.            (load-binary (filename)
  241.          (let* ((binary (merge-pathnames filename binary-path))
  242.             (fwd (and (probe-file binary) (file-write-date binary))))
  243.            (unless (and fwd
  244.                 (let ((lfwd (gethash filename *clio-file-table*)))
  245.                   (eql fwd lfwd)))
  246.              (load binary))
  247.            (setf (gethash filename *clio-file-table*) fwd)))
  248.            (compile-and-load (filename &optional (binary-filename filename))
  249.          (compile-lisp filename binary-filename)
  250.          (load-binary binary-filename))
  251.            (module (filename) (compile-and-load filename)))
  252.  
  253.     ;; Now compile and load all the files.
  254.     (module "clio")
  255.     (module "ol-defs")
  256.     (module "utility")
  257.     (module "core-mixins")
  258.     (module "gravity")
  259.     (module "buffer")
  260.     (module "text-command")
  261.     (module "display-text")
  262.     (module "ol-images")
  263.     (module "buttons")
  264.     (module "confirm")
  265.     (module "scroller")
  266.     (module "table")
  267.     (module "choices")
  268.     (module "form")
  269.     (module "menu")
  270.     (module "psheet")
  271.     (module "command")
  272.     (module "edit-text")
  273.     (module "slider")
  274.     (module "scroll-frame")
  275.     (module "mchoices")
  276.     (module "dlog-button")
  277.     (module "display-imag")))))
  278.  
  279. (defun load-clio (&optional
  280.           (binary-pathname-defaults *clio-binary-pathname*))
  281.  
  282.   ;; The pathname-defaults above might only be strings, so coerce them
  283.   ;; to pathnames.  Build a default binary path with every component
  284.   ;; of the source except the file type.  
  285.   (let* ((source-path (pathname ""))
  286.      (path        (make-pathname
  287.                :host      (pathname-host      source-path)
  288.                :device    (pathname-device    source-path)
  289.                :directory (pathname-directory source-path)
  290.                :name      (pathname-name      source-path)
  291.                :type      nil
  292.                :version   (pathname-version   source-path)))
  293.      (binary-path (merge-pathnames binary-pathname-defaults
  294.                        path)))
  295.  
  296.     (labels ((load-binary (filename)
  297.            (let* ((binary (merge-pathnames filename binary-path))
  298.               (fwd (and (probe-file binary) (file-write-date binary))))
  299.          (unless (and fwd
  300.                   (let ((lfwd (gethash filename *clio-file-table*)))
  301.                 (eql fwd lfwd)))
  302.            (load binary))
  303.          (setf (gethash filename *clio-file-table*) fwd)))
  304.          (module (filename) (load-binary filename)))
  305.  
  306.       ;; Now load all the files.
  307.       (module "clio")
  308.       (module "ol-defs")
  309.       (module "utility")
  310.       (module "core-mixins")
  311.       (module "gravity")
  312.       (module "buffer")
  313.       (module "text-command")
  314.       (module "display-text")
  315.       (module "ol-images")
  316.       (module "buttons")
  317.       (module "confirm")
  318.       (module "scroller")
  319.       (module "table")
  320.       (module "choices")
  321.       (module "form")
  322.       (module "menu")
  323.       (module "psheet")
  324.       (module "command")
  325.       (module "edit-text")
  326.       (module "slider")
  327.       (module "scroll-frame")
  328.       (module "mchoices")
  329.       (module "dlog-button")
  330.       (module "display-imag"))))
  331.  
  332. )
  333.  
  334.